home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / iteration.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  8.8 KB  |  452 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. */
  21.  
  22. /*
  23.  
  24.     iteration.c
  25.  
  26. */
  27.  
  28. #include "include.h"
  29.  
  30. Floop(form)
  31. object form;
  32. {
  33.     object x;
  34.     object *oldlex = lex_env;
  35.     object id;
  36.     object *top;
  37.  
  38.     make_nil_block();
  39.  
  40.     if (nlj_active) {
  41.         nlj_active = FALSE;
  42.         frs_pop();
  43.         lex_env = oldlex;
  44.         return;
  45.     }
  46.  
  47.     top = vs_top;
  48.  
  49.     for(x = form; !endp(x); x = MMcdr(x)) {
  50.         vs_top = top;
  51.         eval(MMcar(x));
  52.     }
  53. LOOP:
  54.     /*  Just !endp(x) is replaced by x != Cnil.  */
  55.     for(x = form;  x != Cnil;  x = MMcdr(x)) {
  56.         vs_top = top;
  57.         eval(MMcar(x));
  58.     }
  59.     goto LOOP;
  60. }
  61.  
  62. /*
  63.     use of VS in Fdo and FdoA:
  64.             |    |
  65.          lex_env ->    | lex1    |
  66.             | lex2    |
  67.             | lex3    |
  68.          start ->    |-------|    where each bt is a bind_temp:
  69.             |  bt1    |
  70.             |-------|    |  var    | -- name of DO variable
  71.                 :        |  spp    | -- T if special
  72.             |-------|    | init    |
  73.             |  btn    |    |  aux    | -- step-form or var (if no
  74.             |-------|             step-form is given)
  75.          end ->    | body    |
  76.          old_top->    |-------|    If 'spp' != T, it is NIL during
  77.                     initialization, and is the pointer to
  78.                     (var value) in lexical environment
  79.                     during the main loop.
  80. */
  81.  
  82. do_var_list(var_list)
  83. object var_list;
  84. {
  85.     object is, x, y;
  86.  
  87.     for (is = var_list;  !endp(is);  is = MMcdr(is)) {
  88.         x = MMcar(is);
  89.            if (type_of(x)==t_symbol)
  90.                {vs_push(x);vs_push(Cnil);vs_push(Cnil);vs_push(x);
  91.             continue;}
  92.    
  93.  
  94.           
  95.  
  96.  
  97.         if (type_of(x) != t_cons)
  98.             FEinvalid_form("The index, ~S, is illegal.", x);
  99.         y = MMcar(x);
  100.         check_var(y);
  101.         vs_push(y);
  102.         vs_push(Cnil);
  103.         if (endp(MMcdr(x))) {
  104.             vs_push(Cnil);
  105.             vs_push(y);
  106.         } else {
  107.             x = MMcdr(x);
  108.             vs_push(MMcar(x));
  109.             if (endp(MMcdr(x)))
  110.                 vs_push(y);
  111.             else {
  112.                 x = MMcdr(x);
  113.                 vs_push(MMcar(x));
  114.                 if (!endp(MMcdr(x)))
  115.                     FEerror("Too many forms to the index ~S.",
  116.                         1, y);
  117.             }
  118.         }
  119.     }
  120. }
  121.  
  122. Fdo(arg)
  123. object arg;
  124. {
  125.     object *oldlex = lex_env;
  126.     object *old_top;
  127.     struct bind_temp *start, *end, *bt;
  128.     object end_test, body;
  129.     VOL object result;
  130.     bds_ptr old_bds_top = bds_top;
  131.  
  132.     if (endp(arg) || endp(MMcdr(arg)))
  133.         FEtoo_few_argumentsF(arg);
  134.     if (endp(MMcadr(arg)))
  135.         FEinvalid_form("The DO end-test, ~S, is illegal.",
  136.                 MMcadr(arg));
  137.  
  138.     end_test = MMcaadr(arg);
  139.     result = MMcdadr(arg);
  140.  
  141.     make_nil_block();
  142.  
  143.     if (nlj_active) {
  144.         nlj_active = FALSE;
  145.         goto END;
  146.     }
  147.  
  148.     start = (struct bind_temp *) vs_top;
  149.  
  150.     do_var_list(MMcar(arg));
  151.     end = (struct bind_temp *)vs_top;
  152.     body = let_bind(MMcddr(arg), start, end);
  153.     vs_push(body);
  154.  
  155.     for (bt = start;  bt < end;  bt++)
  156.         if ((enum stype)bt->bt_var->s.s_stype != stp_ordinary)
  157.             bt->bt_spp = Ct;
  158.         else if (bt->bt_spp == Cnil)
  159.             bt->bt_spp = assoc_eq(bt->bt_var, lex_env[0]);
  160.  
  161.     old_top = vs_top;
  162.  
  163. LOOP:    /* the main loop */
  164.     vs_top = old_top;
  165.     eval(end_test);
  166.     if (vs_base[0] != Cnil) {
  167.         /* RESULT evaluation */
  168.         if (endp(result)) {
  169.             vs_base = vs_top = old_top;
  170.             vs_push(Cnil);
  171.         } else
  172.             do {
  173.                 vs_top = old_top;
  174.                 eval(MMcar(result));
  175.                 result = MMcdr(result);
  176.             } while (!endp(result));
  177.         goto END;
  178.     }
  179.  
  180.     vs_top = old_top;
  181.  
  182.     Ftagbody(body);
  183.  
  184.     /* next step */
  185.     for (bt = start;  bt<end;  bt++) {
  186.         if (bt->bt_aux != bt->bt_var) {
  187.             eval_assign(bt->bt_init, bt->bt_aux);
  188.         }
  189.     }
  190.     for (bt = start;  bt<end;  bt++) {
  191.         if (bt->bt_aux != bt->bt_var)
  192.             if (bt->bt_spp == Ct)
  193.                 bt->bt_var->s.s_dbind = bt->bt_init;
  194.             else
  195.                 MMcadr(bt->bt_spp) = bt->bt_init;
  196.     }
  197.     goto LOOP;
  198.  
  199. END:
  200.     bds_unwind(old_bds_top);
  201.     frs_pop();
  202.     lex_env = oldlex;
  203. }
  204.  
  205. FdoA(arg)
  206. object arg;
  207. {
  208.     object *oldlex = lex_env;
  209.     object *old_top;
  210.     struct bind_temp *start, *end, *bt;
  211.     object end_test, body;
  212.     VOL object result;
  213.     bds_ptr old_bds_top = bds_top;
  214.  
  215.     if (endp(arg) || endp(MMcdr(arg)))
  216.         FEtoo_few_argumentsF(arg);
  217.     if (endp(MMcadr(arg)))
  218.         FEinvalid_form("The DO* end-test, ~S, is illegal.",
  219.                 MMcadr(arg));
  220.  
  221.     end_test = MMcaadr(arg);
  222.     result = MMcdadr(arg);
  223.  
  224.     make_nil_block();
  225.  
  226.     if (nlj_active) {
  227.         nlj_active = FALSE;
  228.         goto END;
  229.     }
  230.  
  231.     start = (struct bind_temp *)vs_top;
  232.     do_var_list(MMcar(arg));
  233.     end = (struct bind_temp *)vs_top;
  234.     body = letA_bind(MMcddr(arg), start, end);
  235.     vs_push(body);
  236.  
  237.     for (bt = start;  bt < end;  bt++)
  238.         if ((enum stype)bt->bt_var->s.s_stype != stp_ordinary)
  239.             bt->bt_spp = Ct;
  240.         else if (bt->bt_spp == Cnil)
  241.             bt->bt_spp = assoc_eq(bt->bt_var, lex_env[0]);
  242.  
  243.     old_top = vs_top;
  244.  
  245. LOOP:    /* the main loop */
  246.     eval(end_test);
  247.     if (vs_base[0] != Cnil) {
  248.         /* RESULT evaluation */
  249.         if (endp(result)) {
  250.             vs_base = vs_top = old_top;
  251.             vs_push(Cnil);
  252.         } else
  253.             do {
  254.                 vs_top = old_top;
  255.                 eval(MMcar(result));
  256.                 result = MMcdr(result);
  257.             } while (!endp(result));
  258.         goto END;
  259.     }
  260.  
  261.     vs_top = old_top;
  262.  
  263.     Ftagbody(body);
  264.  
  265.     /* next step */
  266.     for (bt = start;  bt < end;  bt++)
  267.         if (bt->bt_aux != bt->bt_var) {
  268.             if (bt->bt_spp == Ct) {
  269.                 eval_assign(bt->bt_var->s.s_dbind, bt->bt_aux);
  270.             } else {
  271.                 eval_assign(MMcadr(bt->bt_spp), bt->bt_aux);
  272.             }
  273.         }
  274.     goto LOOP;
  275.  
  276. END:
  277.     bds_unwind(old_bds_top);
  278.     frs_pop();
  279.     lex_env = oldlex;
  280. }
  281.  
  282. Fdolist(arg)
  283. object arg;
  284. {
  285.     object *oldlex = lex_env;
  286.     object *old_top;
  287.     struct bind_temp *start;
  288.     object x, listform, body;
  289.     VOL object result;
  290.     bds_ptr old_bds_top = bds_top;
  291.  
  292.     if (endp(arg))
  293.         FEtoo_few_argumentsF(arg);
  294.  
  295.     x = MMcar(arg);
  296.     if (endp(x))
  297.         FEerror("No variable.", 0);
  298.     start = (struct bind_temp *)vs_top;
  299.     vs_push(MMcar(x));
  300.     vs_push(Cnil);
  301.     vs_push(Cnil);
  302.     vs_push(Cnil);
  303.     x = MMcdr(x);
  304.     if (endp(x))
  305.         FEerror("No listform.", 0);
  306.     listform = MMcar(x);
  307.     x = MMcdr(x);
  308.     if (endp(x))
  309.         result = Cnil;
  310.     else {
  311.         result = MMcar(x);
  312.         if (!endp(MMcdr(x)))
  313.             FEerror("Too many resultforms.", 0);
  314.     }
  315.  
  316.     make_nil_block();
  317.  
  318.     if (nlj_active) {
  319.         nlj_active = FALSE;
  320.         goto END;
  321.     }
  322.  
  323.     eval_assign(start->bt_init, listform);
  324.     body = find_special(MMcdr(arg), start, start+1);
  325.     vs_push(body);
  326.     bind_var(start->bt_var, Cnil, start->bt_spp);
  327.     if ((enum stype)start->bt_var->s.s_stype != stp_ordinary)
  328.         start->bt_spp = Ct;
  329.     else if (start->bt_spp == Cnil)
  330.         start->bt_spp = assoc_eq(start->bt_var, lex_env[0]);
  331.  
  332.     old_top = vs_top;
  333.  
  334. LOOP:    /* the main loop */
  335.     if (endp(start->bt_init)) {
  336.         if (start->bt_spp == Ct)
  337.             start->bt_var->s.s_dbind = Cnil;
  338.         else
  339.             MMcadr(start->bt_spp) = Cnil;
  340.         eval(result);
  341.         goto END;
  342.     }
  343.  
  344.     if (start->bt_spp == Ct)
  345.         start->bt_var->s.s_dbind = MMcar(start->bt_init);
  346.     else
  347.         MMcadr(start->bt_spp) = MMcar(start->bt_init);
  348.     start->bt_init = MMcdr(start->bt_init);
  349.  
  350.     vs_top = old_top;
  351.  
  352.     Ftagbody(body);
  353.  
  354.     goto LOOP;
  355.  
  356. END:
  357.     bds_unwind(old_bds_top);
  358.     frs_pop();
  359.     lex_env = oldlex;
  360. }
  361.  
  362. Fdotimes(arg)
  363. object arg;
  364. {
  365.     object *oldlex = lex_env;
  366.     object *old_top;
  367.     struct bind_temp *start;
  368.     object x, countform, body;
  369.     VOL object result;
  370.     bds_ptr old_bds_top = bds_top;
  371.  
  372.     if (endp(arg))
  373.         FEtoo_few_argumentsF(arg);
  374.  
  375.     x = MMcar(arg);
  376.     if (endp(x))
  377.         FEerror("No variable.", 0);
  378.     start = (struct bind_temp *)vs_top;
  379.     vs_push(MMcar(x));
  380.     vs_push(Cnil);
  381.     vs_push(Cnil);
  382.     vs_push(Cnil);
  383.     x = MMcdr(x);
  384.     if (endp(x))
  385.         FEerror("No countform.", 0);
  386.     countform = MMcar(x);
  387.     x = MMcdr(x);
  388.     if (endp(x))
  389.         result = Cnil;
  390.     else {
  391.         result = MMcar(x);
  392.         if (!endp(MMcdr(x)))
  393.             FEerror("Too many resultforms.", 0);
  394.     }
  395.  
  396.     make_nil_block();
  397.  
  398.     if (nlj_active) {
  399.         nlj_active = FALSE;
  400.         goto END;
  401.     }
  402.  
  403.     eval_assign(start->bt_init, countform);
  404.     if (type_of(start->bt_init) != t_fixnum &&
  405.         type_of(start->bt_init) != t_bignum)
  406.         FEwrong_type_argument(Sinteger, start->bt_init);
  407.     body = find_special(MMcdr(arg), start, start+1);
  408.     vs_push(body);
  409.     bind_var(start->bt_var, make_fixnum(0), start->bt_spp);
  410.     if ((enum stype)start->bt_var->s.s_stype != stp_ordinary) {
  411.         start->bt_spp = Ct;
  412.         x = start->bt_var->s.s_dbind;
  413.     } else if (start->bt_spp == Cnil) {
  414.         start->bt_spp = assoc_eq(start->bt_var, lex_env[0]);
  415.         x = MMcadr(start->bt_spp);
  416.     } else
  417.         x = start->bt_var->s.s_dbind;
  418.  
  419.     old_top = vs_top;
  420.  
  421. LOOP:    /* the main loop */
  422.     if (number_compare(x, start->bt_init) >= 0) {
  423.         eval(result);
  424.         goto END;
  425.     }
  426.  
  427.     vs_top = old_top;
  428.  
  429.     Ftagbody(body);
  430.  
  431.     if (start->bt_spp == Ct)
  432.         x = start->bt_var->s.s_dbind = one_plus(x);
  433.     else
  434.         x = MMcadr(start->bt_spp) = one_plus(x);
  435.  
  436.     goto LOOP;
  437.  
  438. END:
  439.     bds_unwind(old_bds_top);
  440.     frs_pop();
  441.     lex_env = oldlex;
  442. }
  443.  
  444. init_iteration()
  445. {
  446.     make_special_form("LOOP", Floop);
  447.     make_special_form("DO", Fdo);
  448.     make_special_form("DO*", FdoA);
  449.     make_special_form("DOLIST", Fdolist);
  450.     make_special_form("DOTIMES", Fdotimes);
  451. }
  452.